home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / traverse.scm < prev    next >
Text File  |  1995-10-13  |  6KB  |  214 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Utility for tracking down storage leaks.
  5. ;
  6. ; Just do (traverse-depth-first obj1) or (traverse-breadth-first obj1),
  7. ; and then (trail obj2) to find out via what path obj1 points to obj2.
  8. ;
  9. ; Breadth first traversal needs misc/queue.scm.
  10.  
  11.  
  12. (define *mark-table* #f)
  13. (define *interesting-table* #f)
  14.  
  15. (define *traverse-count* 0)
  16.  
  17. (define (start-over)        
  18.   (flush-the-symbol-table!)
  19.   (set! *mark-table* (make-table hash))
  20.   (set! *interesting-table* (make-table))
  21.   (set! *traverse-count* 0))
  22.  
  23. (define (traverse-depth-first obj)
  24.   (start-over)
  25.   (let recur ((obj obj) (parent (list 'root)) (parent-tag 'root))
  26.     (if (stored? obj)
  27.     (if (not (table-ref *mark-table* obj))
  28.         (let ((tag (visit obj parent parent-tag)))
  29.           (for-each-subobject (lambda (child)
  30.                     (recur child obj tag))
  31.                   obj))))))
  32.  
  33. (define (traverse-breadth-first obj)
  34.   (start-over)
  35.   (let ((queue (make-queue)))
  36.     (define (deal-with obj parent parent-tag)
  37.       (if (stored? obj)
  38.       (if (not (table-ref *mark-table* obj))
  39.           (enqueue queue
  40.                (cons obj
  41.                  (visit obj parent parent-tag))))))
  42.     (deal-with obj (list 'root) 'root)
  43.     (let loop ()
  44.       (if (not (queue-empty? queue))
  45.       (let* ((parent+tag (dequeue queue))
  46.          (parent (car parent+tag))
  47.          (parent-tag (cdr parent+tag)))
  48.         (for-each-subobject (lambda (obj)
  49.                   (deal-with obj parent parent-tag))
  50.                 parent)
  51.         (loop))))))
  52.  
  53. (define (visit obj parent parent-tag)
  54.   (table-set! *mark-table* obj parent)
  55.   (if (interesting? obj)
  56.       (let ((tag *traverse-count*))
  57.     (table-set! *interesting-table* tag obj)
  58.     (set! *traverse-count* (+ *traverse-count* 1))
  59.     (write tag) (display " ")
  60.     (write (list parent-tag))
  61.     (display ": ") (write obj) (newline)
  62.     tag)
  63.       parent-tag))
  64.  
  65. (define (trail obj)
  66.   (let loop ((obj (if (integer? obj)
  67.               (table-ref *interesting-table* obj)
  68.               obj)))
  69.     (let ((probe (table-ref *mark-table* obj)))
  70.       (if probe
  71.       (loop probe))
  72.       (if (not (vector? obj))
  73.       (begin (write obj)
  74.          (newline))))))
  75.  
  76. (define (interesting? obj)
  77.   (and (closure? obj)
  78.        (let ((info (template-info (closure-template obj))))
  79.      (if (integer? info)
  80.          (> info first-interesting-template-info)
  81.          #t))))
  82.  
  83. (define (template-info tem) (template-ref tem 1))
  84.  
  85. (define first-interesting-template-info
  86.   (template-info (closure-template read))) ;foo
  87.   
  88. ;(define (interesting? obj)
  89. ;  (if (pair? obj)
  90. ;      #f
  91. ;      (if (vector? obj)
  92. ;          #f
  93. ;          #t)))
  94.       
  95. (define (for-each-subobject proc obj)
  96.   (cond ((pair? obj)
  97.      (proc (car obj))
  98.      (proc (cdr obj)))
  99.     ((symbol? obj)
  100.      (proc (symbol->string obj)))
  101.     ((vector? obj)
  102.      (vector-for-each proc obj))
  103.     ((closure? obj)
  104.      (proc (closure-template obj))
  105.      (proc (closure-env obj)))
  106.     ((location? obj)
  107.      (proc (location-id obj))
  108.      (if (location-defined? obj)
  109.          (proc (contents obj))))
  110.     ((record? obj)
  111.      (cond ((eq? obj *mark-table*)    ;or (debug-data-table)
  112.         (display "skipping mark table") (newline))
  113.            ((eq? obj *interesting-table*)
  114.         (display "skipping interesting table") (newline))
  115.            (else
  116.         (record-for-each proc obj))))
  117.     ((continuation? obj)
  118.      (continuation-for-each proc obj))
  119.     ((template? obj)
  120.      (template-for-each proc obj))
  121.     ((extended-number? obj)
  122.      (extended-number-for-each proc obj))))
  123.  
  124.  
  125. (define (vector-for-each proc v)
  126.   (let ((z (vector-length v)))
  127.     (do ((i (- z 1) (- i 1)))
  128.     ((< i 0) #f)
  129.       (if (not (vector-unassigned? v i))
  130.       (proc (vector-ref v i))))))
  131.  
  132. (define-syntax define-for-each
  133.   (syntax-rules ()
  134.     ((define-for-each foo-for-each foo-length foo-ref)
  135.      (define (foo-for-each proc v)
  136.        (let ((z (foo-length v)))
  137.      (do ((i (- z 1) (- i 1)))
  138.          ((< i 0) #f)
  139.        (proc (foo-ref v i))))))))
  140.  
  141. (define-for-each record-for-each
  142.   record-length record-ref)
  143. (define-for-each continuation-for-each
  144.   continuation-length continuation-ref)
  145. (define-for-each template-for-each
  146.   template-length template-ref)
  147. (define-for-each extended-number-for-each
  148.   extended-number-length extended-number-ref)
  149.  
  150.  
  151. (define (quick-hash obj n)
  152.   (cond ((symbol? obj) (string-hash (symbol->string obj)))
  153.     ((location? obj) (+ 3 (quick-hash (location-id obj) n)))
  154.     ((string? obj) (+ 33 (string-hash obj)))
  155.     ((integer? obj) (if (and (>= obj 0)
  156.                  (< obj hash-mask))
  157.                 obj
  158.                 (modulo obj hash-mask)))
  159.     ((char? obj) (+ 333 (char->integer obj)))
  160.     ((eq? obj #f) 3001)
  161.     ((eq? obj #t) 3003)
  162.     ((null? obj) 3005)
  163.     ((pair? obj) (if (= n 0)
  164.              30007
  165.              (+ (quick-hash (car obj) (- n 1))
  166.                 (quick-hash (cdr obj) (- n 1)))))
  167.     ((vector? obj) (if (= n 0)
  168.                30009
  169.                (if (> (vector-length obj) 1)
  170.                    (+ 30011 (quick-hash (vector-ref obj 1)
  171.                             (- n 1)))
  172.                    30017)))
  173.     ((number? obj) 4000)
  174.     ((closure? obj) 4004)
  175.     ((template? obj) (if (= n 0)
  176.                  300013
  177.                  (+ 30027 (quick-hash (template-ref obj 1)
  178.                           (- n 1)))))
  179.     ((output-port? obj) 4006)
  180.     ((input-port? obj) 4007)
  181.     ((record? obj) 4008)
  182.     ((continuation? obj) 4009)
  183.     ((number? obj) 40010)
  184.     ((string? obj) 40011)
  185.     ((code-vector? obj) 40012)
  186.     ((eq? obj (unspecific)) 40013)
  187.     (else 50007)))
  188.  
  189. (define hash-mask (- (arithmetic-shift 1 26) 1))
  190.  
  191. (define (hash obj) (quick-hash obj 1))
  192.  
  193. (define (leaf? obj)
  194.   (or (and (number? obj)
  195.        (not (extended-number? obj)))
  196.       ;; (symbol? obj)
  197.       (string? obj)
  198.       (code-vector? obj)
  199.       (char? obj)
  200.       (eq? obj #f)
  201.       (eq? obj #t)
  202.       (eq? obj '())
  203.       (eq? obj (unspecific))))
  204.  
  205. (define usual-leaf-predicate leaf?)
  206.  
  207. (define (set-leaf-predicate! proc) (set! leaf? proc))
  208.  
  209. (define (stored? obj) (not (leaf? obj)))
  210.  
  211. (define least-fixnum (arithmetic-shift -1 29))
  212. (define greatest-fixnum (- -1 least-fixnum))
  213.  
  214.